perm filename MKCON[CRE,BGB]1 blob
sn#033843 filedate 1973-04-12 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00027 PAGES
RECORD PAGE DESCRIPTION
00001 00001
00004 00002 MAKE CONTOUR IMAGE.
00005 00003 MKCON(Q1,Q2). MAKE CONTOUR IMAGE: VIDEO → CONTOUR.
00007 00004 MKIMAG(FILM). MKLEVL(IMAGE,CUT).
00009 00005 MKNODE(TYPE). MAKE A NODE.
00010 00006 RINGIN(PART,WHOLE) ATTACH A NODE INTO A RING.
00011 00007 THRESH(LEVEL). PAXOR.
00013 00008 HISTOG. BIMOD.
00016 00009 MKPGON(LEVEL). MAKE POLYGON BY TRACING BIT RASTER BLOB.
00018 00010 MKPGON SUB-OPERATIONS.
00019 00011 THE ALCHEMIST OF MKPGON.
00022 00012 VICONT(LEVEL). VECTOR INTENSITY CONTRAST.
00025 00013 VICONT CONTINUED.
00026 00014 MKSKY(LEVEL). MAKE BORDER POLYGON & SKY ARRAY.
00029 00015 MKTREE(LEVEL). ATTACH(P1,P2). DETACH(P1).
00032 00016 INTREE(P1). PUT POLYGON INTO THE TREE.
00034 00017 INTREE CONTINUED.
00036 00018 INSKY(PGON). PUT A POLYGON IN THE SKY ARRAY.
00038 00019 KILVIC(LEVEL). KILL CONTOURS OF THE PREVIOUS LEVEL.
00040 00020 KLBABY(LEVEL). KILL BABY POLYGONS OF A LEVEL.
00042 00021 KLPGON(PGON).
00044 00022 SMOOTH(LEVEL).
00046 00023 ARCONT(LEVEL). ARC CONTRAST.
00048 00024 SQRT(X). SQUARE ROOT. AC-TRANSPARENT.
00050 00025 MKARCS(V1,V2). MAKE ARCS FROM V1 CCW TO V2.
00053 00026 FARCL(PGON). FIT ARCS LINEAR.
00055 00027 FITS ARCS LINEAR CONTINUED.
00058 ENDMK
⊗;
;MAKE CONTOUR IMAGE.
TITLE MKCON
EXTERN FLGARC,FLGBK,FTVSIX,FLGKRK,FLGU
EXTERN FTVHIS,ARCWID,CTRL,META
EXTERN PAC,STADPY,TVBUF,SEGTV
EXTERN HISTO,HSEG,VSEG,FILM
EXTERN ROWPTR,COLPTR,DPYIMG
ISAVED:0
DECLARE{IMAGE,LEVEL,POLYGON}
;MKCON(Q1,Q2). MAKE CONTOUR IMAGE: VIDEO → CONTOUR.
SUBR(MKCON)Q1,Q2 ----------------------------------------------
BEGIN MKCON
;BIT POSITIONS OF THE ARGUMENTS Q1 & Q2 ENABLE INTENSITY CUTS.
LAC 1,ARG2↔DAC 1,Q0
LAC 1,ARG1↔ANDCMI 1,377↔DAC 1,Q1
SETZM CUT#
;MAKE THE IMAGE BLOCK AND THE LEVEL -1 FRAME POLYGON.
SETQ IMAGE,{MKIMAG,FILM}
SETQ LEVEL,{MKLEVL,IMAGE,[-1]}
SETQ POLYGON,{MKSKY,LEVEL} ;BORDER & SKY.
CALL(SEGTV)
;FIND AN INTENSITY CONTOUR ENABLE BIT.
L0: LAC 0,Q0↔LAC 1,Q1
L1: AOS 2,CUT↔LSHC 0,1↔JUMPL 0,L2
CAMN 0,1↔JUMPE 0,L5↔GO L1
;THRESHOLD THE TVBUF
L2: DAC 0,Q0↔DAC 1,Q1
CALL(THRESH,CUT)
CALL(PACXOR)
;MAKE LEVEL NODE WITH A RING OF POLYGON NODES.
SETQ(LEVEL,{MKLEVL,IMAGE,CUT})
L3: SETQ(POLYGON,{MKPGON,LEVEL})
JUMPN 1,L3↔LAC 1,LEVEL↔SON 1,1↔JUMPE 1,L0
;LEVEL OPERATIONS.
L4: CALL(VICONT,LEVEL)
CALL(KLBABY,LEVEL)
CALL(SMOOTH,LEVEL)
CALL(ARCONT,LEVEL)
CALL(MKTREE,LEVEL)
CALL(KILVIC,LEVEL)
CALL(STADPY)
GO L0
;IMAGE OPERATIONS.
L5: SETZ↔SKIPE FLGKRK↔CORE2↔JFCL ;KILL SKY ARRAY.
LAC 1,LEVEL↔CCW 1,1
CALL(KILVIC,1)
LAC 1,IMAGE↔POP2J
DECLARE{Q0,Q1}
BEND MKCON; BGB 6 DECEMBER 1972 ----------------------------------
;MKIMAG(FILM). MKLEVL(IMAGE,CUT).
SUBR(MKIMAG)FILM--------------------------------------------------
BEGIN MKIMAG; MAKE IMAGE NODE - BGB - 10 JANUARY 1973.
SETQ(IMAGE,{MKNODE,[IBIT+IMGREL]})
CALL(RINGIN,IMAGE,FILM)
LAC 1,IMAGE↔LAC 2,FILM
SON. 1,2↔DAD. 2,1
LIPI 1,(1)↔DAC 1,3(1)↔DAC 1,4(1)↔DAC 1,5(1) ;FEV-RINGS.
POP1J
BEND;1/10/73------------------------------------------------------
SUBR(MKLEVL)IMAGE,CUT---------------------------------------------
BEGIN MKLEVL; MAKE LEVEL NODE - BGB - 10 JANUARY 1973.
SETQ(LEVEL,{MKNODE,[LBIT+LVLREL]})
CALL(RINGIN,LEVEL,IMAGE)
LAC 1,LEVEL↔LAC 2,IMAGE
LAC 0,ARG1↔NCNT. 0,1
SKIPGE↔SON. 1,2↔DAD. 2,1
POP2J
BEND;1/10/73------------------------------------------------------
;MKNODE(TYPE). MAKE A NODE.
SUBR(MKNODE)TYPE -------------------------------------------------
BEGIN MKNODE
EXTERN MORCOR,AVAIL,BLKCNT
SKIPN 1,@AVAIL
CALL(MORCOR)
CDR(1)↔DAP @AVAIL
SETZM(1)↔AOS @BLKCNT
POP P,.+3↔POP P,2(1)↔GO @.+1↔0
POP1J
BEND MKNODE; BGB 10 JANUARY 1973 ---------------------------------
;KLNODE(NODE). KILL A NODE.
SUBR(KLNODE)NODE--------------------------------------------------
BEGIN KLNODE
LAC 1,ARG1
SOS @BLKCNT
SETZM(1)↔LIPI(1)↔LAPI 1(1)↔BLT NODSIZ-1(1)
LAC @AVAIL↔DAPZ(1)↔DAPZ 1,@AVAIL
POP1J
BEND KLNODE; BGB 17 DECEMBER 1972 --------------------------------
;RINGIN(PART,WHOLE) ATTACH A NODE INTO A RING.
SUBR(RINGIN)PART,WHOLE -------------------------------------------
BEGIN RINGIN
LAC 1,ARG2
LAC 3,ARG1
SON 2,3
JUMPE 2,[SON. 1,3↔DIP 1,(1)↔DAP 1,(1)↔POP2J]
CAR 3,(2)
DIP 3,(1)↔DAP 1,(3)
DAP 2,(1)↔DIP 1,(2)
POP2J↔LIT
BEND RINGIN; BGB 6 DECEMBER 1972 ---------------------------------
;THRESH(LEVEL). PAXOR.
SUBR(THRESH)------------------------------------------------------
BEGIN THRESH
SKIPE FLGKRK↔DETSEG
;SOUTH TO PAC FOR PIXELS ≥ CUT.
I←13 ↔ J←14
CALL(SEGTV)
LAC [XWD L,2]↔BLT 13
LAC ARG1↔LSH -3↔DAC HCUT
LAP 5,ARG1
GO 3
;ACCUMULATOR LOOP.
L: POINT 6,TVBUF,-1
MOVEI J,=36 ;3
ILDB 2 ;4
SUBI ;CUT ;5
ROTC 1 ;6
SOJG J,4 ;7
SETCAM 1,PAC(I) ;10
AOBJN I,3 ;11
POP1J ;12
XWD -=1728,0 ;13
BEND THRESH;BGB 4 DECEMBER 1972 ----------------------------------
HCUT: 0 ;HCUT GLOBAL FROM THRESH TO MKPGONS.
;PACXOR. ROOK'S MOVE XOR'ING ON 1-BIT IMAGE.
SUBR(PACXOR)------------------------------------------------------
BEGIN PACXOR
I←2
SLACI PAC↔LAPI HSEG↔BLT HSEG+=1727
SLACI PAC↔LAPI VSEG↔BLT VSEG+=1727
SETZ I,
HRRI PAC↔DAP L+2
L: TRNN I,7↔SETZ 1,↔LAC PAC(I)
XORM HSEG+8(I) ; HSEG SOUBIT are above PAC bits.
ROTC -1↔ROT 1,1
XORM VSEG(I) ; VSEG are left of PAC bits.
AOS I
CAIE I,=1728
GO L
SETZM ISAVED
POP0J
BEND PACXOR; BGB 4 DECEMBER 1972 ---------------------------------
;HISTOG. BIMOD.
SUBR(HISTOG)---------------------------------------------------
BEGIN HISTOG;MAKE HISTOGRAM OF TVBUF - BGB - 4 DEC 72.
CALL(SEGTV)
SKIPE FTVHIS↔POP0J↔SETOM FTVHIS
LAC[XWD HISTO,HISTO+1]↔SETZM HISTO↔BLT HISTO+77
LAC 7,[XWD L,0]↔BLT 7,6↔GO 2
;ACCUMULATOR LOOP.
L: =62208 ;0
0 ;1
ILDB 1,6 ;2
AOS HISTO(1) ;3
SOJG 0,2 ;4
POP0J ;5
POINT 6,TVBUF,-1;6
BEND;12/16/72-----------------------------------------------------
SUBR(BIMOD)-------------------------------------------------------
BEGIN BIMOD;BI-MODAL HISTOGRAM CUT HIGH AND CUT LOW - 14 DEC 72.
ACCUMULATORS{Q1,Q2,HI,LO}
CALL(HISTOG)
LACI HI,77↔SETZM LO↔SETZB Q1,Q2
SETZ↔SKIPE CTRL↔GO[INCHRW↔ANDI 17↔GO .+1]
SKIPE META↔GO[INCHRW 1↔ANDI 1,17↔IMULI =10↔ADD 1↔GO .+1]
SKIPN↔LACI 3↔IMULI =62208↔IDIVI =100↔DAC 1
;COME IN FROM THE EXTREMES 3 PER CENT.
SETZ↔ADD HISTO(LO)↔CAMGE 1↔AOJA LO,.-2
SETZ↔ADD HISTO(HI)↔CAMGE 1↔SOJA HI,.-2
L2: CAML LO,HI↔POP0J
SKIPN FTVSIX↔GO L3
;LOOK FOR LOCAL MINIMUM.
LAC HISTO(LO)↔CAML HISTO+1(LO)↔AOJA LO,L2
LAC HISTO(LO)↔CAML HISTO-1(LO)↔AOJA LO,L2
LAC HISTO(HI)↔CAML HISTO+1(HI)↔SOJA HI,L2
LAC HISTO(HI)↔CAML HISTO-1(HI)↔SOJA HI,L2
;CUT 'EM UP AND DISPLAY 'EM.
L3: MOVNS LO↔MOVNS HI
SETZ Q2,↔SLACI Q1,1B18↔LSHC Q1,(LO)
SETZB 0,1↔SLACI 1B18↔LSHC(HI)↔IOR Q1,0↔IOR Q2,1
CALL(MKCON,Q1,Q2)
CALL(DPYIMG)
POP0J
BEND;12/14/72-----------------------------------------------------
;MKPGON(LEVEL). MAKE POLYGON BY TRACING BIT RASTER BLOB.
SUBR(MKPGON)LEVEL--------------------------------------------------
BEGIN MKPGON;MAKE AN INTENSITY CONTOUR POLYGON - BGB - AUGUST 1972.
ACCUMULATORS{A2,A3,RC.,MASK,I,PTR,D,E,V,PG,BITQ,H1,H2}
LAC H1,HCUT↔LACI H2,7↔SUB H2,H1
LAC I,ISAVED↔CDR PTR,ARG1↔LACI BITQ,VREL
SLACI I↔HRRI PAC↔DAC PACPTR#; PAC POINTER INDEXED BY I.
;FIND THE ROW & COL OF THE UPPER LEFT MOST VSEG.
L1: SKIPE 1,VSEG(I)↔GO L2
AOS I↔CAIE I,=1728↔GO L1
SETZ 1,↔POP1J;EMPTY.
L2: DAC I,ISAVED↔JFFO 1,.+1↔SLACI MASK,400000
MOVNS 2↔LSH MASK,(2)↔MOVNS 2
LAC RC.,I↔ANDI RC.,7↔IMULI RC.,=36↔ADD RC.,2 ;COLUMN.
LAC I↔LSH -3↔DIP RC.↔LSH RC.,6 ;ROW.
;DISTINGUISH BLOBS FROM HOLES.
SETZM HOLE#
TDNN MASK,@PACPTR ;HOLE OR BLOB ?
SETOM HOLE# ;HOLE'A'COMING.
SKIPE HOLE↔EXCH H1,H2
;AND HEAD SOUTH.
SETQ(PG,{MKNODE,[PBIT+PGNREL]})
LAC 0,ARG1↔DAD. 0,PG↔CALL(RINGIN,PG,0)
SKIPE HOLE↔GO[MARK PG,HOLBIT↔GO .+1]
DAC RC.,RCMIN#
SETZM RCMAX#
SETZ V,↔SETZM ECNT#
PUSHJ P,FOLLOW
LAC V,V0
CCW. V,E↔CW. E,V
;MAKE & RETURN VIC POLYGON.
LAC 1,ECNT↔SKIPE HOLE#↔MOVNS 1
NCNT. 1,PG
LAC V0↔SON. 0,PG ;UPPER MOST LEFT.
LAC V1↔ARC. 0,PG ;LOWER MOST RIGHT.
LAC 1,PG
L3: POP1J
;MKPGON SUB-OPERATIONS.
DEFINE TRY (SEG,YES) {
LAC SEG(I)↔TDZN MASK↔GO .+3↔DAC SEG(I)↔GO YES}
DEFINE LEFT {SUBI RC.,100↔ROT MASK,1↔CAIN MASK,1↔SOS I}
DEFINE RIGHT {ADDI RC.,100↔ROT MASK,-1↔SKIPG MASK↔AOS I}
DEFINE UP {SUB RC.,[1B11]↔SUBI I,8}
DEFINE DOWN {ADD RC.,[1B11]↔ADDI I,8}
;CREATE NEW EDGE AND VERTEX OF A VIC.
TURN: 0
AOS TURNS#
ADD D,RC.
AOS 2,ECNT
;VERTEX
CALL(MKNODE,BITQ)
PGON. PG,1
SKIPN V↔GO[DAC 1,V0#↔DAC 1,V↔GO T2]
DAC 1,V
CCW. V,E↔CW. E,V
T2: DAC D,RC(V)
CAMLE D,RCMAX
GO[DAC D,RCMAX↔DAC V,V1#↔GO .+1]
DAC V,E
GO @TURN
;THE ALCHEMIST OF MKPGON.
;converts bits of lead into lines of gold.
NORTH: ADD D,[1B11]↔LIPI BITQ,(NORBIT+VBIT)↔JSR TURN
NORTH2: LEFT↔LAC D,DELPM(H1)↔TRY HSEG,WEST
RIGHT↔UP↔TRY VSEG,NORTH2
DOWN↔LAC D,DELPP(H2)↔TRY HSEG,EAST↔FATAL(NORTH)
NORTH3: LIPI BITQ,(NORBIT+VBIT)↔JSR TURN↔LEFT
NORTH4: UP↔LAC D,DELPM(H1)↔TRY HSEG,WEST↔GO NORTH4
WEST: ADDI D,100↔LIPI BITQ,(WESBIT+VBIT)↔JSR TURN
WEST2: CAMN RC.,RCMIN↔POPJ P,
FOLLOW: LAC D,DELPP(H1)↔TRY VSEG,SOUTH
LEFT↔TRY HSEG,WEST2
RIGHT↔UP↔LAC D,DELMP(H2)↔TRY VSEG,NORTH↔FATAL(WEST)
SOUTH: LIPI BITQ,(SOUBIT+VBIT)↔JSR TURN
SOUTH2: DOWN↔LAC D,DELMP(H1)
CAR RC.↔CAIN =216B29↔GO EAST3
TRY HSEG, EAST↔TRY VSEG,SOUTH2
LEFT↔LAC D,DELMM(H2)↔TRY HSEG,WEST↔FATAL(SOUTH)
EAST: LIPI BITQ,(EASBIT+VBIT)↔JSR TURN
EAST2: RIGHT↔LAC D,DELMM(H1)
CDR RC.↔CAIN =288B29↔GO NORTH3
UP↔TRY VSEG,NORTH
DOWN↔TRY HSEG,EAST2
LAC D,DELPM(H2)↔TRY VSEG,SOUTH↔FATAL(EAST)
EAST3: LIPI BITQ,(EASBIT+VBIT)↔JSR TURN↔UP
EAST4: RIGHT↔LAC D,DELMM(H1)
CDR RC.↔CAIN =288B29↔GO[DOWN↔GO NORTH3]
TRY VSEG,NORTH↔GO EAST4
;DEKINKING OFF SETS.
DELPP: FOR I←24,33{XWD I,I↔}
DELPM: FOR I←24,33{XWD I,-I↔}
DELMP: FOR I←24,33{XWD -I,I↔}
DELMM: FOR I←24,33{XWD -I,-I↔}
BEND MKPGON;BGB AUGUST 1972 ---------------------------------------
;VICONT(LEVEL). VECTOR INTENSITY CONTRAST.
SUBR(VICONT)LEVEL-------------------------------------------------
BEGIN VICONT
ACCUMULATORS{R1,C1,V1,R2,C2,V2,PG,QQNW,QQSE,CNT,PTR,SAVCNT}
CALL(SEGTV)
LAC 1,ARG1↔SON PG,1↔DAC PG,PG0# ;FIRST POLYGON.
L1: SON V2,PG↔DAC V2,V0# ;FIRST VECTOR.
LAC RC(V2)↔ADD[XWD 40,40]
CAR R2,↔LSH R2,-6
CDR C2,↔LSH C2,-6
L2: LAC V1,V2↔LAC R1,R2↔LAC C1,C2↔CCW V2,V2 ;NEXT VECTOR.
LAC RC(V2)↔ADD[XWD 40,40]
CAR R2,↔LSH R2,-6↔CDR C2,↔LSH C2,-6 ;GET ROW & COL.
SETZB QQNW,QQSE
TESTZ V1,WESBIT↔GO WEST
TESTZ V1,SOUBIT↔GO SOUTH
TESTZ V1,EASBIT↔GO EAST
TESTZ V1,NORBIT↔GO NORTH↔HALT
L3: CAME V2,V0↔GO L2
CCW PG,PG↔CAME PG,PG0↔GO L1 ;NEXT POLYGON.
POP1J
;-----------------------------------------------------------------
WEST: LAC ROWPTR(R2)↔ADD COLPTR-1(C2)
LAC CNT,C1↔SUB CNT,C2↔CALL(EW)
SUB QQSE,QQNW
NTIME. QQSE,V1↔PTIME. SAVCNT,V1
IDIV QQSE,SAVCNT
CNTRS. QQSE,V1↔GO L3
SOUTH: LAC ROWPTR(R1)↔ADD COLPTR-2(C1)
LAC CNT,R2↔SUB CNT,R1↔CALL(NS)
SUB QQSE,QQNW
NTIME. QQSE,V1↔PTIME. SAVCNT,V1
IDIV QQSE,SAVCNT
CNTRS. QQSE,V1↔GO L3
EAST: LAC ROWPTR(R1)↔ADD COLPTR-1(C1)
LAC CNT,C2↔SUB CNT,C1↔CALL(EW)
SUB QQNW,QQSE
NTIME. QQNW,V1↔PTIME. SAVCNT,V1
IDIV QQNW,SAVCNT
CNTRS. QQNW,V1↔GO L3
NORTH: LAC ROWPTR(R2)↔ADD COLPTR-2(C2)
LAC CNT,R1↔SUB CNT,R2↔CALL(NS)
SUB QQNW,QQSE
NTIME. QQNW,V1↔PTIME. SAVCNT,V1
IDIV QQNW,SAVCNT
CNTRS. QQNW,V1↔GO L3
DECLARE{PTRNW,PTRSE}
;-----------------------------------------------------------------
;VICONT CONTINUED.
;EAST-WEST.
EW: DAC CNT,SAVCNT
TLZ 1↔DAC PTRSE
SUBI=48↔DAC PTRNW
EWL: ILDB PTRNW↔ADDM QQNW
ILDB PTRSE↔ADDM QQSE
SOJG CNT,EWL
CAIG R1,0↔SETZ QQNW,
CAIL R1,=216↔SETZ QQSE,
POP0J
;NORTH-SOUTH.
NS: DAC CNT,SAVCNT↔TLZ 1↔DAC PTR↔TDCA 1,1
NSL: LACI 1,=48↔ADDB 1,PTR
ILDB 1↔ADDM QQNW
ILDB 1↔ADDM QQSE
SOJG CNT,NSL
CAIG C1,0↔SETZ QQNW,
CAIL C1,=288↔SETZ QQSE,
POP0J
BEND VICONT; BGB 14 DECEMBER 1972 --------------------------------
;MKSKY(LEVEL). MAKE BORDER POLYGON & SKY ARRAY.
;POINTERS TO SKY ROWS - COLUMN ACCUMULATOR 3.
SKYSEG: 0
SKY: FOR I←0,=216{
$ + =289*I (3) }
SUBR(MKSKY)LEVEL--------------------------------------------------
BEGIN MKSKY
ACCUMULATORS{R,C,N,S,E,W,M,LVL}
SETQ(M,{MKNODE,[PBIT+PGNREL]})
LAC LVL,ARG1↔DAD. LVL,1
CALL(RINGIN,M,LVL)
LACI R,=216⊗6↔LACI C,=288⊗6
;VERTEX-POLYGON POLYGON.
SETQ(W,{MKNODE,[VBIT+SOUBIT+VREL]})↔PGON. M,W
SETQ(S,{MKNODE,[VBIT+EASBIT+VREL]})↔PGON. M,S
SETQ(E,{MKNODE,[VBIT+NORBIT+VREL]})↔PGON. M,E
SETQ(N,{MKNODE,[VBIT+WESBIT+VREL]})↔PGON. M,N
ROW. R,S↔ROW. R,E↔COL. C,E↔COL. C,N
CW. N,W ↔ CW. E,N ↔ CW. S,E ↔ CW. W,S
CCW. S,W ↔ CCW. E,S ↔ CCW. N,E ↔ CCW. W,N
SON. W,M↔LAC 1,M
SKIPN FLGKRK↔POP1J
;MAKE THAT BIG ARRAY UP THERE IN THE SKY.
L1: DETSEG↔LACI =217*=289↔CORE2
GO[FATAL(AIN'T NO MORE CORE UP YONDER.)]
LAC[SIXBIT/SKYSEG/]↔SETNM2↔JFCL
SETZ↔SEGNUM↔DAC SKYSEG
;PUT THE BORDER POLYGON UP IN THE SKY.
LAC[XWD $,$+1]↔SETZM $↔BLT $+=217*=289-1
L2: SETZ C,↔LACI R,=216↔DAP W,@SKY(R)↔SOJGE R,.-1
LACI R,=216
LACI C,=288↔DAP E,@SKY(R)↔SOJGE R,.-1
;ARC BORDER POLYGON.
LACI R,=216⊗6↔LACI C,=288⊗6
CALL(MKNODE,[ARCBIT+VBIT+VREL])↔ARC. 1,W↔ARC. W,1↔LAC W,1
CALL(MKNODE,[ARCBIT+VBIT+VREL])↔ARC. 1,S↔ARC. S,1↔LAC S,1
CALL(MKNODE,[ARCBIT+VBIT+VREL])↔ARC. 1,E↔ARC. E,1↔LAC E,1
CALL(MKNODE,[ARCBIT+VBIT+VREL])↔ARC. 1,N↔ARC. N,1↔LAC N,1
ROW. R,S↔ROW. R,E↔COL. C,E↔COL. C,N
PGON. M,W↔PGON. M,S↔PGON. M,E↔PGON. M,N
CW. N,W ↔ CW. E,N ↔ CW. S,E ↔ CW. W,S
CCW. S,W ↔ CCW. E,S ↔ CCW. N,E ↔ CCW. W,N
ARC. W,M
L3: LAC 1,M↔POP1J
BEND MKSKY; BGB 4 DECEMBER 1972 ----------------------------------
;MKTREE(LEVEL). ATTACH(P1,P2). DETACH(P1).
SUBR(MKTREE)LEVEL-----------------------------------------------
BEGIN MKTREE;MAKE POLYGON TREE STRUCTURE USING SKY ARRAY.
;BGB - 19 DECEMBER 1972.
SKIPN FLGKRK↔POP1J
DETSEG↔LAC SKYSEG
ATTSEG↔GO[FATAL(SKYSEG ATTACH FAILURE IN MKIMAG.)]
;PLACE POLYGONS OF THIS LEVEL IN THE TREE AND IN THE SKY.
LAC 1,ARG1↔SON 1,1↔DAC 1,PG0#↔DAC 1,POLYGON
L1: CALL(INTREE,POLYGON)
LAC 1,POLYGON
CCW 1,1
DAC 1,POLYGON
CAME 1,PG0↔GO L1
DETSEG↔POP1J
BEND;1/23/73------------------------------------------------------
SUBR(ATTACH)P1,P2-----------------------------------------------
BEGIN ATTACH;PLACE P1 WITHIN P2 - BGB - 23 JANUARY 1973.
LAC 1,ARG2↔LAC 2,ARG1
EXO. 2,1↔ENDO 3,2 ;EXO(P1)←P2;P3←ENDO(P);
JUMPN 3,.+5 ;IF P3=0 THEN BEGIN
ENDO. 1,2↔PGON. 1,1 ;ENDO(P2)←NGON(P1)←PGON(P1)←P1;
NGON. 1,1↔POP2J ;RETURN;END;
NGON 4,3 ;P4←NGON(P3);
PGON. 1,4↔NGON. 1,3 ;PGON(P4)←NGON(P3)←P1;
NGON. 4,1↔PGON. 3,1 ;NGON(P1)←P4;PGON(P1)←P3;
POP2J
BEND;1/23/73------------------------------------------------------
SUBR(DETACH)P1--------------------------------------------------
BEGIN DETACH;REMOVE P1 FROM THE TREE - BGB - 23 JANUARY 1973.
LAC 1,ARG1
NGON 2,1↔PGON 3,1 ;P2←NGON(P1);P3←PGON(P1);
PGON. 3,2↔NGON. 2,3 ;PGON(P2)←P3;NGON(P3)←P2;
NGON. 1,1↔PGON. 1,1 ;NGON(P1)←PGON(P1)←P1;
CAMN 3,1↔SETZ 3, ;IF P3=P1 THEN P3←NIL;
EXO 2,1↔ENDO 0,2 ;P2←EXO(P1);P0←ENDO(P2);
CAMN 0,1↔ENDO. 3,2 ;IF P0=P1 THEN ENDO(P2)←P3;
POP1J
BEND;1/23/73------------------------------------------------------
;INTREE(P1). PUT POLYGON INTO THE TREE.
SUBR(INTREE)P1----------------------------------------------------
BEGIN INTREE
ACCUMULATORS{R,C,E,LST,P0,P1,P2,P3}
LAC P1,ARG1
SON E,P1↔JUMPE E,POP1J.
LAC RC(E)↔ADD[XWD 40,40]
CAR R,↔LSH R,-6
CDR C,↔LSH C,-6
TESTZ P1,HOLBIT↔SOS C
;FIND THE VERTICAL EDGE DUE EAST OF HERE.
L0: SKIPN 1,@SKY(R)↔SOJA C,L0
PGON P2,1↔CAMN P2,P1↔SOJA C,L0
;PLACE P1 WITHIN P2, IN THE TREE AND IN THE SKY.
TEST 1,SOUBIT↔EXO P2,P2
CALL(ATTACH,P1,P2)
CALL(INSKY,P1)
;CONS UP LIST OF P2'S ENDO POLYGONS.
LAC P1,ARG1↔HRLOI LST,0 ;LIST ← NIL.
EXO P2,P1↔ENDO P3,P2↔JUMPE P3,POP1J. ;AIN'T NONE.
DAC P3,P0
L1: CAMN P3,P1↔GO L2
PTIME. LST,P3↔LAC LST,P3 ;CONS P3 TO LIST.
L2: NGON P3,P3↔CAME P3,P0↔GO L1 ;CDR THE RING.
;INTREE CONTINUED.
;SCAN LIST FOR P1 ENDO POLYGONS. P2←CDR(LIST).
L3: CAIN LST,-1↔SETZ LST,
SKIPN P2,LST↔POP1J↔SON E,P2
LAC RC(E)↔ADD[XWD 40,40]
CAR R,↔LSH R,-6
CDR C,↔LSH C,-6
;SCAN FOR FIRST POLYGON TO THE EAST OF P2.
L4: JUMPL C,L7
SKIPN 1,@SKY(R)↔SOJA C,L4
PGON P3,1↔CAMN P3,LST↔SOJA C,[
EXO 1,1↔JUMPE 1,L4↔GO L6] ;HACK.
TESTZ 1,SOUBIT↔GO L5 ;SKIP ON BRO. GO ON DAD.
;IF BROTHER IS NOT ON THE P-LIST THEN EXO(P3) IS VALID.
L4A: LAC P0,P3↔EXO P3,P3
PTIME 0,P0↔JUMPE 0,L5
;IF BROTHER IS ON P-LIST THEN EXO(P3) IS NOT YET VALID AND MUST
;BE SAVED ON AN N-LIST.
NTIME 0,P0↔NTIME. 0,P2
NTIME. P2,P0↔GO L6
;CHECK FOR P1 CAPTURE OF P2. P3 IS THE SKY-EXO(P2).
L5: EXO 0,P2
CAMN 0,P3↔GO L6 ;EXO(P2)=SKYEXO(P2).
CALL(DETACH,P2)
CALL(ATTACH,P2,P1)
;CAPTURE OLDER BROTHER OFF THE N-LIST OF P2.
L6: LAC 1,P2↔SETZ
NTIME P2,P2
NTIME. 0,1
JUMPN P2,L5
;CDR THE P-LIST OF POTENTIAL ENDO POLYGONS.
L7: LAC 1,LST↔SETZ
PTIME LST,LST↔PTIME. 0,1
GO L3
BEND INTREE; BGB 23 JANUARY 1973 ---------------------------------
;INSKY(PGON). PUT A POLYGON IN THE SKY ARRAY.
SUBR(INSKY)PGON---------------------------------------------------
BEGIN INSKY
ACCUMULATORS{R,C,R2,C2,E,E2}
DEFINE ADVANCE{
LAC E,E2↔LAC R,R2↔LAC C,C2
CCW E2,E2↔LAC RC(E2)↔ADD[XWD 40,40]
CAR R2,↔LSH R2,-6
CDR C2,↔LSH C2,-6}
;XWD HORIZONTAL,,VERTICAL.
LAC 1,ARG1↔SON E,1
DAC E,E0#↔JUMPE E,POP1J.
CW E2,E↔ADVANCE↔ADVANCE↔GO SSA
;SOUTH ↓ BOUND.
S0: CAMN E,E0↔POP1J
SSA: CDR 1,@SKY(R)↔EXO. 1,E
S1: CDR 1,@SKY(R)↔DAP E,@SKY(R)
CAIE R2,(R)1↔AOJA R,S1↔ADVANCE
TEST E,EASBIT↔GO W0↔GO EE0
;NORTH ↑ BOUND.
N0: SOS R↔CDR 1,@SKY(R)↔EXO. 1,E
N1: CDR 1,@SKY(R)↔DAP E,@SKY(R)
CAME R,R2↔SOJA R,N1↔ADVANCE
TEST E,EASBIT↔GO W0↔GO EE0
;EAST → BOUND.
EE0: ADVANCE
TEST E,NORBIT↔GO S0↔GO N0
;WEST ← BOUND.
W0: ADVANCE
TEST E,NORBIT↔GO S0↔GO N0
BEND INSKY;BGB 7 DECEMBER 1972 -----------------------------------
;KILVIC(LEVEL). KILL CONTOURS OF THE PREVIOUS LEVEL.
SUBR(KILVIC)LEVEL-------------------------------------------------
BEGIN KILVIC
ACCUMULATORS{PG,E0,E1,E2,PG0}
SKIPN FLGARC↔POP1J ;MAKE ARC ENABLE.
SKIPN FLGU↔POP1J
LAC 1,ARG1↔CW 1,1
SON PG,1
SKIPN PG0,PG↔POP1J
;RELEASE VIC NODES OF THE POLYGON.
L1: SON E0,PG
JUMPE E0,L3
SETZ↔SON. 0,PG
LAC E1,E0
L2: CCW E2,E1
SETZ 0↔ARC 1,E1↔SKIPE 1↔ARC. 0,1
CALL(KLNODE,E1)
CAMN E2,E0↔GO L3
LAC E1,E2↔GO L2
;ADVANCE TO NEXT POLYGON ON THIS LEVEL.
L3: CCW PG,PG
CAME PG,PG0↔GO L1
POP1J
BEND KILVIC; BGB 5 JANUARY 1973 ----------------------------------
;KLBABY(LEVEL). KILL BABY POLYGONS OF A LEVEL.
SUBR(KLBABY)LEVEL ------------------------------------------------
BEGIN KLBABY
ACCUMULATORS{A,PG,E0,E1,E2,Q,R}
SKIPN FLGBK↔POP1J
LAC 1,ARG1↔SON PG,1↔DAC PG,PG0#
;KLUDGE - SPARE SON POLYGON UNTIL WE CAN THINK OF A POLICY.
GO L3
;ELIMINATE INSIGNIFICANT CONTOURS - SMALL LOW CONTRAST.
L1: NCNT 0,PG↔LACM
CAIL =10↔GO L3
;RELEASE VIC NODES OF THE POLYGON.
SON E0,PG
LAC E1,E0
L2: CCW E2,E1
CALL(KLNODE,E1)
CAMN E2,E0↔GO .+3
LAC E1,E2↔GO L2
;KILL A BABY POLYGON.
CAR Q,(PG)↔CDR R,(PG)
DIP Q,(R)↔ DAP R,(Q) ;RINGO PG.
CALL(KLNODE,PG)
SKIPA PG,R ;CCW FROM OUT OF THE GRAVE.
;ADVANCE TO NEXT POLYGON ON THIS LEVEL.
L3: CCW PG,PG↔CAME PG,PG0↔GO L1
POP1J
BEND;1/6/73------------------------------------------------------
;KLPGON(PGON).
SUBR(KLPGON)POLYGON-----------------------------------------------
BEGIN KLPGON;KILL POLYGON RETURN CCW(PGN) - BGB - 7 JANUARY 1973.
ACCUMULATORS{PG,E0,E1,E2,Q,R}
LAC PG,ARG1
;RELEASE VIC NODES OF THE POLYGON.
SON E0,PG
LAC E1,E0
L1: CCW E2,E1
CALL(KLNODE,E1)
CAMN E2,E0↔GO .+3
LAC E1,E2↔GO L1
;RING OUT & KILL POLYGON NODE,
NGON Q,PG↔PGON R,PG↔JUMPE R,L2
NGON. Q,R↔PGON. R,Q↔CAMN PG,R↔SETZ R,
EXO 1,PG↔JUMPE 1,.+4↔ENDO 0,1↔CAMN 0,PG↔ENDO. R,1
ENDO 1,PG↔SKIPE 1↔ZIP 3(1) ;MY ENDO BECOMES AN ORPHAN.
L2: CAR Q,(PG)↔CDR R,(PG)
DIP Q,(R)↔ DAP R,(Q) ;RINGO PG.
CALL(KLNODE,PG)
;DOES DAD NEED A NEW FIRST SON.
DAD 1,R
CAMN PG,R↔SETZ R,
SON 0,1↔CAMN 0,PG↔SON. R,1
;RETURN PGON CCW FROM OUT OF THE GRAVE.
LAC 1,R
POP1J
BEND;1/8/73------------------------------------------------------
;SMOOTH(LEVEL).
SUBR(SMOOTH)LEVEL-------------------------------------------------
BEGIN SMOOTH; -BGB- 6 DEC 1972.
ACCUMULATORS{V1,V2,PG,E0,E1,E2}
SKIPN FLGARC↔POP1J ;MAKE ARC ENABLED ?
LAC 1,ARG1
SON PG,1↔SKIPN PG↔POP1J
;POLYGON INITIALIZATION.
L1: DAC PG,PGSAVE#
SON V1,PG↔DAC V1,E0SAVE# ;UPPER MOST LEFT VERTEX.
ARC V2,PG ;LOWER MOST RIGHT VERTEX.
TESTZ V2,ARCBIT↔POP1J ;END OF LEVEL'S POLYGON RING.
;CREATE ARC NODES AT POLYGON'S EXTREME CORNERS.
SETQ(ARC2,{MKNODE,[VBIT+ARCBIT+VREL]})
LAC RC(V2)↔DAC RC(1)↔ARC. 1,V2↔ARC. V2,1
SETQ(ARC1,{MKNODE,[VBIT+ARCBIT+VREL]})
LAC RC(V1)↔DAC RC(1)↔ARC. 1,V1↔ARC. V1,1
LAC 2,ARC2↔CCW. 1,2↔CW. 1,2↔CCW. 2,1↔CW. 2,1
PGON. PG,1↔PGON. PG,2↔ARC. 1,PG
;CALL FOR CREATION OF THE INTERMEDIATE ARC NODES.
SETZM AVCNT
CALL(MKARCS,ARC1,ARC2)
CALL(MKARCS,ARC2,ARC1)
;KILL TWO-SIDED ARC-POLYGONS AND ADVANCE TO NEXT POLYGON.
SKIPN AVCNT↔GO[
SETQ(PG,{KLPGON,PGSAVE})
JUMPN PG,L1↔POP1J]
LAC PG,PGSAVE↔CCW PG,PG↔GO L1
LIT
DECLARE{ARC1,ARC2}
BEND;1/9/73-------------------------------------------------------
DECLARE{AVCNT} ;ARC-VERTEX COUNT.
;ARCONT(LEVEL). ARC CONTRAST.
SUBR(ARCONT)LEVEL-------------------------------------------------
BEGIN ARCONT;ARC CONTRAST - BGB - 21 JANUARY 1973.
ACCUMULATORS{QNS,QEW,A1,A2,V1,V2,PG,PG0,A0}
;FOR ALL THE ARCS OF THIS LEVEL.
LAC 1,ARG1
SON PG,1↔DAC PG,PG0 ;FIRST POLYGON.
L1: ARC A2,PG↔DAC A2,A0 ;FIRST ARC.
L2: LAC A1,A2↔ARC V1,A1
CCW A2,A1↔ARC V2,A2
;ACCUMULATE VECTOR CONTRAST,,LENGTH ALONG THE ARC.
SETZB QNS,QEW
L3: TESTZ V1,NORBIT+SOUBIT↔GO[
ADD QNS,6(V1)↔GO .+2]
ADD QEW,6(V1)
CCW V1,V1
CAME V1,V2↔GO L3
;COMPUTE ARC CONTRAST: SIN↑2*VERTICAL + COS↑2*HORIZONTAL.
CAR 0,QNS↔FSC 0,233
CDR 1,QNS↔FSC 1,233↔FDVR 0,1
HLLZ 1,6(A1)↔FMPR 0,1↔DAC 0,QNS
CAR 0,QEW↔FSC 0,233
CDR 1,QEW↔FSC 1,233↔FDVR 0,1
HRLZ 1,6(A1)↔FMPR 0,1↔FADR 0,QNS
FIX 0,233000↔CNTRS. 0,A1
CAME A2,A0↔GO L2 ;LAST ARC OF THE POLYGON ?
CCW PG,PG
CAME PG,PG0↔GO L1 ;LAST POLYGON OF THE LEVEL ?
POP1J
BEND;1/21/73------------------------------------------------------
;SQRT(X). SQUARE ROOT. AC-TRANSPARENT.
SUBR(SQRT)X ------------------------------------------------------
BEGIN SQRT
A←←0 ↔ B←←1 ↔ C←←2
LACM B,ARG1↔JUMPE B,L2
PUSH P,A↔PUSH P,C
;LET X=F*(2↑2B) WHERE 0.25<F<1.00 THEN SQRT(X)=SQRT(F)*(2↑B).
ASHC B,-=27↔SUBI B,201 ;PUT EXPONENT IN B, FRACTION IN C.
ROT B,-1 ;CUT EXP IN HALF, SAVE ODD BIT.
DAP B,L1↔LSH B,-=35 ;USE THAT ODD BIT.
ASH C,-10↔FSC C,177(B) ;0.25 < FRACTION < 1.00
;LINEAR APPROXIMATION TO SQRT(F).
DAC C,A
FMP C,[0.8125↔0.578125](B)
FAD C,[0.302734↔0.421875](B)
;TWO ITERATIONS OF NEWTON'S METHOD.
LAC B,A
FDV B,C↔FAD C,B↔FSC C,-1
FDV A,C↔FADR A,C
L1: FSC A,0↔LAC 1,A
POP P,C↔POP P,A
L2: SUB P,[2(2)]↔GO@2(P)
BEND SQRT; BGB 28 DECEMBER 1972 ----------------------------------
;MKARCS(V1,V2). MAKE ARCS FROM V1 CCW TO V2.
SUBR(MKARCS)V1,V2-------------------------------------------------
BEGIN MKARCS
ACCUMULATORS{D,U1,U2,V1,V2,A,B,C,U,V}
LAC V1,ARG2↔LAC V2,ARG1
;CHECK FOR TRIVAIL CASE.
L0: ARC U1,V1↔ARC U2,V2
CCW 0,U1↔CAMN 0,U2↔GO L3
;COMPUTE NORMALIZED ARC EDGE COEFFICIENTS.
ROW A,V1↔FLO A, ; A ← Y1.
COL B,V2↔FLO B, ; B ← X2.
COL C,V1↔FLO C, ; C ← X1.
ROW D,V2↔FLO D, ; D ← Y2.
LAC 1,B↔FMPR 1,A ; 1 ← X2*Y1.
FSBR A,D↔FSBR B,C ; A ← Y1-Y2. B ← X2-X1.
FMPR C,D↔FSBR C,1 ; C ← X1*Y2 - X2*Y1.
LAC 0,A↔FMPR 0,0↔LAC 1,B↔FMPR 1,1↔FADR 1,0
CALL SQRT,1↔FDVR A,1↔FDVR B,1↔FDVR C,1
LAC 0,A↔FMPR 0,A↔HLLM 0,6(V1)
LAC 0,B↔FMPR 0,B↔HLRM 0,6(V1)
;SET 'EM UP FOR AN ARC PASS.
ARC U1,V1↔ARC U2,V2
SETZM DMAX#↔SETZM DMIN#
SETZM VMAX#↔SETZM VMIN#↔SETZM MAXCON#
;GO FROM U1 CCW TO U2 AND FIND THE U FURTHEST OFF THE ARC-EDGE.
L1: CCW U1,U1↔CAMN U1,U2↔GO L2
COL 0,U1↔FLO 0,↔ROW 1,U1↔FLO 1,
FMPR 0,A↔FMPR 1,B↔LAC D,C↔FADR D,0↔FADR D,1
CAMGE D,DMIN↔GO [DAC U1,VMIN↔DAC D,DMIN↔GO .+1]
CAMLE D,DMAX↔GO [DAC U1,VMAX↔DAC D,DMAX↔GO .+1]
;KEEP TRACK OF MAXIMUM EDGE CONTRAST ALONG ARC.
CNTRST 0,V1↔MOVM↔CAMLE MAXCON↔DAC MAXCON↔GO L1
;WHEN EXTREMA EXCEED ARCWID[MAXCON] THEN FORM ARC-POINTS.
L2: LAC U,VMIN↔LACM DMIN
CAMGE DMAX↔LAC U,VMAX
CAMGE DMAX↔LAC DMAX
LAC 1,MAXCON↔CAMGE ARCWID(1)↔GO L3
;OLDE ESPLIT.
SETQ(V,{MKNODE,[VBIT+ARCBIT+VREL]})↔AOS AVCNT
ARC. U,V↔ARC. V,U
LAC RC(U)↔DAC RC(V)↔PGON 0,U↔PGON. 0,V
CCW. V,V1↔CW. V1,V
CCW. V2,V↔CW. V,V2
LAC V2,V↔GO L0
;ADVANCE CCW AN ARC-EDGE OR EXIT.
L3: CAMN V2,ARG1↔POP2J
LAC V1,V2↔CCW V2,V2↔GO L0
BEND;28/12/72-----------------------------------------------------
;FARCL(PGON). FIT ARCS LINEAR.
SUBR(FARCL)PGON---------------------------------------------------
BEGIN FARCL; FIT ARCS LINEAR.
X←←1
ACCUMULATORS{Y,SX,SY,XX,YY,XY,N,E,U1,U2,V1,V2}
;Clear the Locus of all the Arc Vertices.
LAC E,ARG1↔CAR E,1(E)↔DAC E,E0#
CCW V1,E ↔ SETZM RC(V1)
CCW E,V1 ↔ CAME E,E0↔JRST .-4
;Advance along Polygon.
CW V2,E
L1: LAC V1,V2↔CCW V2,E
ARC U1,V1↔ARC U2,V2
CW U1,U1↔CW U1,U1
CW U1,U1↔CW U1,U1
CW U1,U1↔CW U1,U1
CCW U2,U2↔CCW U2,U2
CCW U2,U2↔CCW U2,U2
CCW U2,U2↔CCW U2,U2
;Arc Scan Initialization.
LAC [XWD SX,SY]↔SETZ SX,↔BLT N↔JRST .+3
;Advance along VIC within the ARC.
L2: CCW U1,U1↔CCW U1,U1
;Accumulate a Point.
CDR X,RC(U1)↔FLO X,↔CAR Y,RC(U1)↔FLO Y,
FAD SX,X ↔ FAD SY,Y
LAC X ↔ FMP Y ↔ FAD XY,0
FMP X,X ↔ FAD XX,X
FMP Y,Y ↔ FAD YY,Y
CAME U1,U2↔AOJA N,L2↔AOS N
;FITS ARCS LINEAR CONTINUED.
;COMPUTE SYMMETRIC LEAST SQUARES LINE COEFFICIENTS.
; Q ← N*XY - SY*SX.
; A ← Q + SY*SY - N*YY.
; B ← Q + SX*SX - N*XX.
; C ← SX*YY + SY*XX - XY*(SX+SY).
L3: LAC 2,SX↔FMP 2,YY
LAC 0,SY↔FMP 0,XX↔FAD 2,0
LAC SX↔FAD SY↔FMP XY↔FSB 2,0↔DAC 2,CCCC#
FSC N,233↔FMP XX,N↔FMP XY,N↔FMP YY,N ;all the N terms.
LAC SX↔FMP SY↔FSB XY,0 ;Q in XY.
FMP SY,SY↔FAD SY,XY↔FSB SY,YY↔DAC SY,AAAA#
FMP SX,SX↔FAD SX,XY↔FSB SX,XX↔DAC SX,BBBB#
FMP SY,SY↔FMP SX,SX↔FAD SX,SY
SLACI(1.0)↔FDVR SX↔DAC QQQQ# ;PSEUDO NORMALIZATION.
;SOLVE FOR THE LOCII WHERE PERPENDICULARS DROPPED FROM
;THE ARC-EDGE HIT THE FITTED LINE.
; Q ← 1/(A*A + B*B).
; D ← (B*X1 - A*Y1).
; X ← (B*D - A*C)*Q.
; Y ←-(A*D + B*C)*Q.
L4: ARC U1,V1
CDR X,RC(U1)↔FLO X,↔CAR Y,RC(U1)↔FLO Y,
FMP X,BBBB↔FMP Y,AAAA↔FSBR X,Y↔LACN Y,X ;DDDD.
FMP X,BBBB↔FMP Y,AAAA
LAC AAAA↔FMP CCCC↔FSBR X,↔FMPR X,QQQQ↔247040226000;FIX
LAC BBBB↔FMP CCCC↔FSBR Y,↔FMPR Y,QQQQ↔247100226000
DIP Y,X↔ADDM X,RC(V1)
ARC U2,V2
CDR X,RC(U2)↔FLO X,↔CAR Y,RC(U2)↔FLO Y,
FMP X,BBBB↔FMP Y,AAAA↔FSBR X,Y↔LACN Y,X ;DDDD.
FMP X,BBBB↔FMP Y,AAAA
LAC AAAA↔FMP CCCC↔FSBR X,↔FMPR X,QQQQ↔247040226000;FIX
LAC BBBB↔FMP CCCC↔FSBR Y,↔FMPR Y,QQQQ↔247100226000
DIP Y,X↔ADDM X,RC(V2)
CCW E,V2↔CAME E,E0↔JRST L1
LAC 12,AC12↔POP1J
BEND;1/6/73-------------------------------------------------------
END